;; Convert a exp to dot node name format.
(defun dot-name (exp)
  (substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp)))

(defparameter *max-label-length* 30)

;; Tuncate long label name
(defun dot-label (exp)
  (if exp
      (let ((s (write-to-string exp :pretty nil)))
        (if (> (length s) *max-label-length*)
            (concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...")
            s))
      ""))

;; Generate dot information for dot nodes.
(defun nodes->dot (nodes)
  (mapc (lambda (exp)
          (princ (dot-name (car exp)))
          (princ "[label=\"")
          (princ (dot-label exp))
          (princ "\"];")
          (princ #\newline))
        nodes))


;; Generate edges information for dot.
(defun edges->dot (edges)
  (mapc (lambda (exp)
          ;; Get src node.
          (let ((src (dot-name (car exp))))
            (mapc (lambda (exp1)
                    (princ src)
                    (princ "->")
                    ;; Get tar node.
                    (princ (dot-name (car exp1)))
                    (princ "[label=\"")
                    ;; Get edge label.
                    (princ (dot-label (cdr exp1)))
                    (princ "\"];")
                    (princ #\newline))
                  (cdr exp))))
        edges))

;; Generate graph dot output.
(defun graph->dot (nodes edges)
  (princ "digraph {")
  (princ #\newline)
  (nodes->dot nodes)
  (edges->dot edges)
  (princ "}"))

;; Convert dot to png file.
(defun dot->png (fname thunk)
  (with-open-file (*standard-output*
                   fname
                   :direction :output
                   :if-exists :supersede)
    (funcall thunk))
  (ext:shell (concatenate 'string "dot -Tpng -O " fname)))

;; Convert graph to dot file.
(defun graph->png (fname nodes edges)
  (dot->png fname (lambda ()
                    (graph->dot nodes edges))))

(defun uedges->dot (edges)
  (maplist (lambda (lst)
             (mapcar (lambda (edge)
                       (unless (assoc (car edge) (cdr lst))
                         (princ (dot-name (caar lst)))
                         (princ "--")
                         ;; Get tar node.
                         (princ (dot-name (car edge)))
                         (princ "[label=\"")
                         ;; Get edge label.
                         (princ (dot-label (cdr edge)))
                         (princ "\"];")
                         (princ #\newline)))
                     (cdar lst)))
           edges))

(defun ugraph->dot (nodes edges)
  (princ "graph {")
  (princ #\newline)
  (nodes->dot nodes)
  (uedges->dot edges)
  (princ "}"))

(defun ugraph->png (fname nodes edges)
  (dot->png fname (lambda()
                    (ugraph->dot nodes edges))))